home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xlsym.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  5KB  |  243 lines

  1. /* xlsym - symbol handling routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL obarray,s_unbound;
  10. extern LVAL xlenv,xlfenv,xldenv;
  11.  
  12. /* forward declarations */
  13. FORWARD LVAL findprop();
  14.  
  15. /* xlenter - enter a symbol into the obarray */
  16. LVAL xlenter(name)
  17.   char *name;
  18. {
  19.     LVAL sym,array;
  20.     int i;
  21.  
  22.     /* check for nil */
  23.     if (strcmp(name,"NIL") == 0)
  24.     return (NIL);
  25.  
  26.     /* check for symbol already in table */
  27.     array = getvalue(obarray);
  28.     i = hash(name,HSIZE);
  29.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  30.     if (strcmp(name,getstring(getpname(car(sym)))) == 0)
  31.         return (car(sym));
  32.  
  33.     /* make a new symbol node and link it into the list */
  34.     xlsave1(sym);
  35.     sym = consd(getelement(array,i));
  36.     rplaca(sym,xlmakesym(name));
  37.     setelement(array,i,sym);
  38.     xlpop();
  39.  
  40.     /* return the new symbol */
  41.     return (car(sym));
  42. }
  43.  
  44. /* xlmakesym - make a new symbol node */
  45. LVAL xlmakesym(name)
  46.   char *name;
  47. {
  48.     LVAL sym;
  49.     sym = cvsymbol(name);
  50.     if (*name == ':')
  51.     setvalue(sym,sym);
  52.     return (sym);
  53. }
  54.  
  55. /* xlgetvalue - get the value of a symbol (with check) */
  56. LVAL xlgetvalue(sym)
  57.   LVAL sym;
  58. {
  59.     LVAL val;
  60.  
  61.     /* look for the value of the symbol */
  62.     while ((val = xlxgetvalue(sym)) == s_unbound)
  63.     xlunbound(sym);
  64.  
  65.     /* return the value */
  66.     return (val);
  67. }
  68.  
  69. /* xlxgetvalue - get the value of a symbol */
  70. LVAL xlxgetvalue(sym)
  71.   LVAL sym;
  72. {
  73.     register LVAL fp,ep;
  74.     LVAL val;
  75.  
  76.     /* check the environment list */
  77.     for (fp = xlenv; fp; fp = cdr(fp))
  78.  
  79.     /* check for an instance variable */
  80.     if ((ep = car(fp)) && objectp(car(ep))) {
  81.         if (xlobgetvalue(ep,sym,&val))
  82.         return (val);
  83.     }
  84.  
  85.     /* check an environment stack frame */
  86.     else {
  87.         for (; ep; ep = cdr(ep))
  88.         if (sym == car(car(ep)))
  89.             return (cdr(car(ep)));
  90.     }
  91.  
  92.     /* return the global value */
  93.     return (getvalue(sym));
  94. }
  95.  
  96. /* xlsetvalue - set the value of a symbol */
  97. xlsetvalue(sym,val)
  98.   LVAL sym,val;
  99. {
  100.     register LVAL fp,ep;
  101.  
  102.     /* look for the symbol in the environment list */
  103.     for (fp = xlenv; fp; fp = cdr(fp))
  104.  
  105.     /* check for an instance variable */
  106.     if ((ep = car(fp)) && objectp(car(ep))) {
  107.         if (xlobsetvalue(ep,sym,val))
  108.         return;
  109.     }
  110.  
  111.     /* check an environment stack frame */
  112.     else {
  113.         for (; ep; ep = cdr(ep))
  114.         if (sym == car(car(ep))) {
  115.             rplacd(car(ep),val);
  116.             return;
  117.         }
  118.     }
  119.  
  120.     /* store the global value */
  121.     setvalue(sym,val);
  122. }
  123.  
  124. /* xlgetfunction - get the functional value of a symbol (with check) */
  125. LVAL xlgetfunction(sym)
  126.   LVAL sym;
  127. {
  128.     LVAL val;
  129.  
  130.     /* look for the functional value of the symbol */
  131.     while ((val = xlxgetfunction(sym)) == s_unbound)
  132.     xlfunbound(sym);
  133.  
  134.     /* return the value */
  135.     return (val);
  136. }
  137.  
  138. /* xlxgetfunction - get the functional value of a symbol */
  139. LVAL xlxgetfunction(sym)
  140.   LVAL sym;
  141. {
  142.     register LVAL fp,ep;
  143.  
  144.     /* check the environment list */
  145.     for (fp = xlfenv; fp; fp = cdr(fp))
  146.     for (ep = car(fp); ep; ep = cdr(ep))
  147.         if (sym == car(car(ep)))
  148.         return (cdr(car(ep)));
  149.  
  150.     /* return the global value */
  151.     return (getfunction(sym));
  152. }
  153.  
  154. /* xlsetfunction - set the functional value of a symbol */
  155. xlsetfunction(sym,val)
  156.   LVAL sym,val;
  157. {
  158.     register LVAL fp,ep;
  159.  
  160.     /* look for the symbol in the environment list */
  161.     for (fp = xlfenv; fp; fp = cdr(fp))
  162.     for (ep = car(fp); ep; ep = cdr(ep))
  163.         if (sym == car(car(ep))) {
  164.         rplacd(car(ep),val);
  165.         return;
  166.         }
  167.  
  168.     /* store the global value */
  169.     setfunction(sym,val);
  170. }
  171.  
  172. /* xlgetprop - get the value of a property */
  173. LVAL xlgetprop(sym,prp)
  174.   LVAL sym,prp;
  175. {
  176.     LVAL p;
  177.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  178. }
  179.  
  180. /* xlputprop - put a property value onto the property list */
  181. xlputprop(sym,val,prp)
  182.   LVAL sym,val,prp;
  183. {
  184.     LVAL pair;
  185.     if (pair = findprop(sym,prp))
  186.     rplaca(pair,val);
  187.     else
  188.     setplist(sym,cons(prp,cons(val,getplist(sym))));
  189. }
  190.  
  191. /* xlremprop - remove a property from a property list */
  192. xlremprop(sym,prp)
  193.   LVAL sym,prp;
  194. {
  195.     LVAL last,p;
  196.     last = NIL;
  197.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  198.     if (car(p) == prp)
  199.         if (last)
  200.         rplacd(last,cdr(cdr(p)));
  201.         else
  202.         setplist(sym,cdr(cdr(p)));
  203.     last = cdr(p);
  204.     }
  205. }
  206.  
  207. /* findprop - find a property pair */
  208. LOCAL LVAL findprop(sym,prp)
  209.   LVAL sym,prp;
  210. {
  211.     LVAL p;
  212.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  213.     if (car(p) == prp)
  214.         return (cdr(p));
  215.     return (NIL);
  216. }
  217.  
  218. /* hash - hash a symbol name string */
  219. int hash(str,len)
  220.   char *str;
  221. {
  222.     int i;
  223.     for (i = 0; *str; )
  224.     i = (i << 2) ^ *str++;
  225.     i %= len;
  226.     return (i < 0 ? -i : i);
  227. }
  228.  
  229. /* xlsinit - symbol initialization routine */
  230. xlsinit()
  231. {
  232.     LVAL array,p;
  233.  
  234.     /* initialize the obarray */
  235.     obarray = xlmakesym("*OBARRAY*");
  236.     array = newvector(HSIZE);
  237.     setvalue(obarray,array);
  238.  
  239.     /* add the symbol *OBARRAY* to the obarray */
  240.     p = consa(obarray);
  241.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  242. }
  243.